Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue63/Debug/HVBordebug/HVDll.pas

Pascal/Delphi Source File | 1999-04-07 | 15.4 KB | 594 lines

unit HVDll;
//
// Support for DelayLoading of DLLs ß la VC++6.0
// Written by Hallvard Vassbotn ([e-mail]), January 1999
// Documentation in The Delphi Magazine, Febrary 1999 issue
// Revised for use in BorDebug.Pas, March 1999
//
interface

uses
  Windows,
  Classes,
  SysUtils;

//
// Simple wrapper classes around the Win32 Heap functions.
// Moved in from the HVHeaps unit
//
type
  // The TPrivateHeap class gives basic memory allocation capability
  // The benefit of using this class instead of the native GetMem
  // and FreeMem routines, is that the memory pages used will
  // be seperate from other allocations. This gives reduced
  // fragmentation.
  TPrivateHeap = class(TObject)
  private
    FHandle: THandle;
    FAllocationFlags: DWORD;
    function GetHandle: THandle;
  public
    constructor Create;
    destructor Destroy; override;
    procedure GetMem(var P{: pointer}; Size: DWORD); virtual;
    procedure FreeMem(P: pointer);
    function SizeOfMem(P: pointer): DWORD;
    property Handle: THandle read GetHandle;
    property AllocationFlags: DWORD read FAllocationFlags write FAllocationFlags;
  end;

  // The Code Heap adds the feature of allocating readable/writable
  // and executable memory blocks. This allows us to have safe
  // run-time generated code while not wasting as much memory
  // as calls to VirtualAlloc would have caused, while avoiding
  // the pitfalls of changing the protection flags of blocks
  // allocated with GetMem.
  TCodeHeap = class(TPrivateHeap)
  public
    procedure GetMem(var P{: pointer}; Size: DWORD); override;
  end;

type
  // Structures to keep the address of function variables and name/id pairs
  PPointer = ^pointer;
  PEntry = ^TEntry;
  TEntry = packed record
    Proc: PPointer;
    case integer of
      0 : (Name: PChar);
      1 : (ID  : Longint);
    end;
  PEntries = ^TEntries;
  TEntries = packed array[0..High(Word)-1] of TEntry;

  // Structures to generate the per-routine thunks
  PThunk = ^TThunk;
  TThunk = packed record
    CALL  : byte;
    OFFSET: integer;
  end;
  PThunks = ^TThunks;
  TThunks = packed array[0..High(Word)-1] of TThunk;

  // Structure to generate the per-DLL thunks
  TThunkHeader = packed record
    PUSH   : byte;
    VALUE  : pointer;
    JMP    : byte;
    OFFSET : integer;
  end;

  // The combined per-DLL and per-routine thunks
  PThunkingCode = ^TThunkingCode;
  TThunkingCode = packed record
    ThunkHeader : TThunkHeader;
    Thunks      : TThunks;
  end;

  // The base class that provides DelayLoad capability
  TDll = class(TObject)
  private
    FEntries  : PEntries;
    FThunkingCode: PThunkingCode;
    FCount    : integer;
    FFullPath : string;
    FHandle   : HMODULE;
    function GetHandle: HMODULE;
    procedure SetFullPath(const Value: string);
    function GetProcs(Index: integer): pointer;
    procedure SetProcs(Index: integer; Value: pointer);
    function GetAvailable: boolean;
    function GetLoaded: boolean;
    function LoadProcAddrFromIndex(Index: integer; var Addr: pointer): boolean;
    procedure ActivateThunks;
    function GetEntryName(Index: integer): string;
  protected
    function LoadHandle: HMODULE; virtual;
    class procedure Error(const Msg: string; Args: array of const);
    procedure CreateThunks;
    procedure DestroyThunks;
    function HasThunk(Thunk: PThunk): boolean;
    function GetProcAddrFromIndex(Index: integer): pointer;
    function DelayLoadFromThunk(Thunk: PThunk): pointer; register;
    function DelayLoadIndex(Index: integer): pointer;
    function GetIndexFromThunk(Thunk: PThunk): integer;
    function GetIndexFromProc(Proc: PPointer): integer;
    function ValidIndex(Index: integer): boolean;
    procedure CheckIndex(Index: integer);
    property Procs[Index: integer]: pointer read GetProcs write SetProcs;
  public
    constructor Create(const DllName: string; const Entries: array of TEntry);
    destructor Destroy; override;
    procedure Load;
    procedure Unload;
    function HasRoutine(Proc: PPointer): boolean;
    function HookRoutine(Proc: PPointer; HookProc: Pointer; var OrgProc{: Pointer}): boolean;
    function UnHookRoutine(Proc: PPointer; var OrgProc{: Pointer}): boolean;
    property FullPath: string read FFullPath write SetFullPath;
    property Handle: HMODULE read GetHandle;
    property Loaded: boolean read GetLoaded;
    property Available: boolean read GetAvailable;
    property Count: integer read FCount;
    property EntryName[Index: integer]: string read GetEntryName;
  end;

  // The class that keeps a list of all created TDll instances in one place
  TDllNotifyAction = (daLoadedDll, daUnloadedDll, daLinkedRoutine);
  TDllNotifyEvent = procedure(Sender: TDll; Action: TDllNotifyAction; Index: integer) of object;
  TDlls = class(TList)
  private
    FCodeHeap: TCodeHeap;
    FOnDllNotify: TDllNotifyEvent;
    function GetDlls(Index: integer): TDll;
  protected
    procedure DllNotify(Sender: TDll; Action: TDllNotifyAction; Index: integer);
    property CodeHeap: TCodeHeap read FCodeHeap;
  public
    constructor Create;
    destructor Destroy; override;
    property Dlls[Index: integer]: TDll read GetDlls; default;
    property OnDllNotify: TDllNotifyEvent read FOnDllNotify write FOnDllNotify;
  end;

  EDllError = class(Exception);

var
  Dlls: TDlls;

implementation

{$IFDEF VER90}
type
  EWin32Error = class(Exception)
  public
    ErrorCode: DWORD;
  end;

const
  SWin32Error = 'Win32 Error.  Code: %d.'#10'%s';
  SUnkWin32Error = 'A Win32 API function failed';

procedure RaiseLastWin32Error;
var
  LastError: DWORD;
  Error: EWin32Error;
begin
  LastError := GetLastError;
  if LastError <> ERROR_SUCCESS then
    Error := EWin32Error.CreateFmt(SWin32Error, [LastError,
      SysErrorMessage(LastError)])
  else
    Error := EWin32Error.Create(SUnkWin32Error);
  Error.ErrorCode := LastError;
  raise Error;
end;

function Win32Check(RetVal: BOOL): BOOL;
begin
  if not RetVal then RaiseLastWin32Error;
  Result := RetVal;
end;
{$ENDIF}

function Win32Handle(Handle: THandle): THandle;
begin
  if Handle = 0 then
    RaiseLastWin32Error;
  Result := Handle;
end;

function Win32Pointer(P: Pointer): Pointer;
begin
  if P = nil then
    RaiseLastWin32Error;
  Result := P;
end;

{ TPrivateHeap }

constructor TPrivateHeap.Create;
begin
  // Do nothing
end;

destructor TPrivateHeap.Destroy;
begin
  if FHandle <> 0 then
  begin
    Win32Check(Windows.HeapDestroy(FHandle));
    FHandle := 0;
  end;
  inherited Destroy;
end;

procedure TPrivateHeap.FreeMem(P: pointer);
begin
  Win32Check(Windows.HeapFree(Handle, 0, P));
end;

function TPrivateHeap.GetHandle: THandle;
begin
  if FHandle = 0 then
    FHandle := Win32Handle(Windows.HeapCreate(0, 0, 0));
  Result := FHandle;
end;

procedure TPrivateHeap.GetMem(var P{: pointer}; Size: DWORD);
begin
  Pointer(P) := Win32Pointer(Windows.HeapAlloc(Handle, AllocationFlags, Size));
end;

function TPrivateHeap.SizeOfMem(P: pointer): DWORD;
begin
  Result := Windows.HeapSize(Handle, 0, P);
  // HeapSize does not set GetLastError, but returns $FFFFFFFF if it fails
  if Result = $FFFFFFFF then
    Result := 0;
end;

{ TCodeHeap }

procedure TCodeHeap.GetMem(var P{: pointer}; Size: DWORD);
var
  Dummy: DWORD;
begin
  inherited GetMem(P, Size);
  Win32Check(Windows.VirtualProtect(Pointer(P), Size, PAGE_EXECUTE_READWRITE, @Dummy));
end;

{$IFDEF VER90}
const
{$ELSE}
resourcestring
{$ENDIF}
  SIndexOutOfRange      = 'DLL-entry index out of range (%d)';
  SOrdinal              = 'ordinal #';
  SCannotLoadLibrary    = 'Could not find the library: "%s"'#13#10'(%s)';
  SCannotGetProcAddress = 'Could not find the routine "%s" in the library "%s"'#13#10'(%s)';
  SCannotFindThunk      = 'Could not find the TDll object corresponding to the thunk address %p';

{ Helper routines }

function EntryToString(const Entry: TEntry): string;
begin
  if Hi(Entry.ID) <> 0
  then Result := string(Entry.Name)
  else Result := SOrdinal+IntToStr(Entry.ID);
end;

procedure ThunkingTarget;
const
  TThunkSize = SizeOf(TThunk);
asm
  // Save register-based parameters
  PUSH    EAX
  PUSH    EDX
  PUSH    ECX
{ Stack layout at this point:
  24 [Stack based parameters]
  20 [User code RetAdr]
  16 [Thunk Ret-Adr]
  12 [Self]
   8 [EAX]
   4 [EDX]
   0 [ECX] <-ESP}
  // Get the caller's return address (i.e. one of the thunks)
  MOV     EAX, [ESP+12]   // Self
  MOV     EDX, [ESP+16]   // Thunk
  // The return address is just after the thunk that
  // called us, so go back one step
  SUB     EDX, TYPE TThunk // Using SizeOf(TThunk) here does not work. BASM bug?
  // Do the rest in Pascal
  CALL    TDll.DelayLoadFromThunk{(Self, Thunk);}
  // Now patch the return address on the stack so that we "return" to the DLL routine
  MOV     [ESP+16], EAX
  // Restore register-based parameters
  POP     ECX
  POP     EDX
  POP     EAX
  // Remove the Self pointer!
  ADD        ESP,  4
  // "RETurn" to the DLL!
end;

{ TDll }

constructor TDll.Create(const DllName: string; const Entries: array of TEntry);
begin
  inherited Create;
  FFullPath := DllName;
  FEntries  := @Entries;
  FCount    := High(Entries) - Low(Entries) + 1;
  CreateThunks;
  ActivateThunks;
  Dlls.Add(Self);
end;

destructor TDll.Destroy;
begin
  Dlls.Remove(Self);
  Unload;
  DestroyThunks;
  inherited Destroy;
end;

procedure TDll.CreateThunks;
const
  CallInstruction = $E8;
  PushInstruction = $68;
  JumpInstruction = $E9;
var
  i : integer;
begin
  // Get a memory block large enough for the thunks
  Dlls.CodeHeap.GetMem(FThunkingCode, SizeOf(TThunkHeader) + SizeOf(TThunk) * Count);

  // Generate some machine code in the thunks
  with FThunkingCode^, ThunkHeader do
  begin
    // The per-Dll thunk does this:
    // PUSH    Self
    // JMP     ThunkingTarget
    PUSH   := PushInstruction;
    VALUE  := Self;
    JMP    := JumpInstruction;
    OFFSET := PChar(@ThunkingTarget) - PChar(@Thunks[0]);
    for i := 0 to Count-1 do
      with Thunks[i] do
      begin
        // The per-entry thunk does this:
        // CALL @ThunkingCode^.ThunkHeader
        CALL   := CallInstruction;
        OFFSET := PChar(@FThunkingCode^.ThunkHeader) - PChar(@Thunks[i+1]);
      end;
  end;
end;

procedure TDll.DestroyThunks;
begin
  if Assigned(FThunkingCode) then
  begin
    Dlls.CodeHeap.FreeMem(FThunkingCode);
    FThunkingCode := nil;
  end;
end;

function TDll.DelayLoadFromThunk(Thunk: PThunk): pointer; register;
begin
  Result := DelayLoadIndex(GetIndexFromThunk(Thunk));
end;

function TDll.DelayLoadIndex(Index: integer): pointer;
begin
  Result := GetProcAddrFromIndex(Index);
  FEntries^[Index].Proc^ := Result;
end;

class procedure TDll.Error(const Msg: string; Args: array of const);
begin
  raise EDllError.CreateFmt(Msg, Args);
end;

function TDll.LoadHandle: HMODULE;
begin
  if FHandle = 0 then
  begin
    FHandle := Windows.LoadLibrary(PChar(FullPath));
    if FHandle <> 0 then
      Dlls.DllNotify(Self, daLoadedDll, -1);
  end;
  Result := FHandle;
end;

function TDll.GetHandle: HMODULE;
begin
  Result := FHandle;
  if Result = 0 then
  begin
    Result := LoadHandle;
    if Result = 0 then
      Error(SCannotLoadLibrary, [FullPath, SysErrorMessage(GetLastError)]);
  end;
end;

function TDll.GetIndexFromThunk(Thunk: PThunk): integer;
begin
  // We calculate the thunk index by subtracting the start of the array
  // and dividing by the size of the array elements
  Result := (PChar(Thunk) - PChar(@FThunkingCode^.Thunks[0])) div SizeOf(TThunk);
end;

function TDll.LoadProcAddrFromIndex(Index: integer; var Addr: pointer): boolean;
begin
  Result := ValidIndex(Index);
  if Result then
  begin
    Addr := Windows.GetProcAddress(Handle, FEntries^[Index].Name);
    Result := Assigned(Addr);
    if Result then
      Dlls.DllNotify(Self, daLinkedRoutine, Index);
  end;
end;

function TDll.GetProcAddrFromIndex(Index: integer): pointer;
begin
  if not LoadProcAddrFromIndex(Index, Result) then
    Error(SCannotGetProcAddress, [EntryName[Index], FullPath, SysErrorMessage(GetLastError)]);
end;

function TDll.HasThunk(Thunk: PThunk): boolean;
begin
  // The thunk belongs to us if its address is in the thunk array
  Result := (PChar(Thunk) >= PChar(@FThunkingCode^.Thunks[0])) and
            (PChar(Thunk) <= PChar(@FThunkingCode^.Thunks[Count-1]));
end;

procedure TDll.Load;
var
  i : integer;
begin
  for i := 0 to Count-1 do
    DelayLoadIndex(i);
end;

procedure TDll.SetFullPath(const Value: string);
begin
  if CompareText(FFullPath, Value) <> 0 then
  begin
    Unload;
    FFullPath := Value;
  end;
end;

function TDll.GetEntryName(Index: integer): string;
begin
  if ValidIndex(Index)
  then Result := EntryToString(FEntries^[Index])
  else Result := Format(SIndexOutOfRange, [Index]);
end;

procedure TDll.ActivateThunks;
// Patch the procedure variables to point to the generated thunks
var
  i : integer;
begin
  for i := 0 to Count-1 do
    FEntries^[i].Proc^ := @FThunkingCode^.Thunks[i];
end;

procedure TDll.Unload;
begin
  ActivateThunks;
  if FHandle <> 0 then
  begin
    FreeLibrary(FHandle);
    Dlls.DllNotify(Self, daUnloadedDll, -1);
    FHandle := 0;
  end;
end;

function TDll.ValidIndex(Index: integer): boolean;
begin
  Result := (Index >= 0) and (Index <= Count-1);
end;

procedure TDll.CheckIndex(Index: integer);
begin
  if not ValidIndex(Index) then
    Error(SIndexOutOfRange, [Index]);
end;

function TDll.GetProcs(Index: integer): pointer;
begin
  CheckIndex(Index);
  Result := FEntries^[Index].Proc^;
end;

procedure TDll.SetProcs(Index: integer; Value: pointer);
begin
  CheckIndex(Index);
  FEntries^[Index].Proc^ := Value;
end;

function TDll.GetAvailable: boolean;
begin
  Result := (LoadHandle <> 0);
end;

function TDll.GetLoaded: boolean;
begin
  Result := (FHandle <> 0);
end;

function TDll.GetIndexFromProc(Proc: PPointer): integer;
begin
  for Result := 0 to Count-1 do
    if FEntries^[Result].Proc = Proc then
      Exit;
  Result := -1;
end;

function TDll.HasRoutine(Proc: PPointer): boolean;
begin
  Result := Available and
            ((not HasThunk(Proc^)) or
              LoadProcAddrFromIndex(GetIndexFromProc(Proc), Proc^));
end;

function TDll.HookRoutine(Proc: PPointer; HookProc: Pointer; var OrgProc{: Pointer}): boolean;
begin
  Result := HasRoutine(Proc);
  if Result then
  begin
    Pointer(OrgProc) := Proc^;
    Proc^   := HookProc;
  end;
end;

function TDll.UnHookRoutine(Proc: PPointer; var OrgProc{: Pointer}): boolean;
begin
  Result := Assigned(Pointer(OrgProc));
  if Result then
  begin
    Proc^ := Pointer(OrgProc);
    Pointer(OrgProc) := nil;
  end;
end;

{ TDlls }

constructor TDlls.Create;
begin
  inherited Create;
  FCodeHeap := TCodeHeap.Create;
end;

destructor TDlls.Destroy;
var
  i : integer;
begin
  for i := Count-1 downto 0 do
    Dlls[i].Free;
  FCodeHeap.Free;
  FCodeHeap := nil;
  inherited Destroy;
end;

procedure TDlls.DllNotify(Sender: TDll; Action: TDllNotifyAction; Index: integer);
begin
  if Assigned(FOnDllNotify) then
    FOnDllNotify(Sender, Action, Index);
end;

function TDlls.GetDlls(Index: integer): TDll;
begin
  Result := TDll(Items[Index]);
end;

initialization
  Dlls := TDlls.Create;
finalization
  Dlls.Free;
  Dlls := nil;
end.